Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue29/system/Midetree/mwIDETree.pas

Pascal/Delphi Source File | 1997-09-16 | 13.5 KB | 482 lines

unit mwIDETree;
{
  Vcl IDETree Expert

  Author:  Martin_Waldenburg
  Created: 09.97
  Version: 0.3 beta
  Status: FreWare
  The RTTI routines are slightly modified
  from the book " Secrets of Delphi 2 "  by Ray Lischner.
  In my opinion the best Delphi book.
  Used with permision. Thanks Ray.
  Secret30.dpl needed.
}

interface

uses SysUtils,
  Classes,
  Messages,
  Consts,
  Forms,
  Windows,
  Dialogs,
  ClipBrd,
  Controls,
  EditIntf,
  ExptIntf,
  ToolIntf,
  ExtCtrls,
  Menus,
  comCtrls,
  StdCtrls,
  LibIntf,
  TypInfo,
  WinTypes,
  S_Rtti;

type
  TfrmIDETree = class(TForm)
    Memo1: TMemo;
    TreeView1: TTreeView;
    Splitter1: TSplitter;
    procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
    procedure FormShow(Sender: TObject);
    procedure TreeView1Deletion(Sender: TObject; Node: TTreeNode);
  private
    { private declarations }
  public
    { public declarations }
  end;

  TIDETreeExpert = class(TIExpert)
  private
    MenuItem: TIMenuItemIntf;
  protected
    procedure OnClick( Sender: TIMenuItemIntf); virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    function GetName: string; override;
    function GetAuthor: string; override;
    function GetStyle: TExpertStyle; override;
    function GetIDString: string; override;
  end;

procedure Register;
procedure WriteTypeInfo(Info: PTypeInfo);

var
  frmIDETree: TfrmIDETree;
  TopNode, Level1Child, Level2Child, Level3Child, Level4Child: TTreenode;

implementation

{$R *.DFM}

procedure Register;
begin
  RegisterLibraryExpert(TIDETreeExpert.Create);
end;

{ TIDETreeExpert code }
function TIDETreeExpert.GetName: String;
begin
  Result := 'IDETreeExpert'
end;

function TIDETreeExpert.GetAuthor: String;
begin
  Result := 'Martin_Waldenburg'; { author }
end;

function TIDETreeExpert.GetStyle: TExpertStyle;
begin
  Result := esAddIn;
end;

function TIDETreeExpert.GetIDString: String;
begin
  Result := 'private.IDETreeExpert';
end;

constructor TIDETreeExpert.Create;
var
  Main: TIMainMenuIntf;
  ReferenceMenuItem: TIMenuItemIntf;
  Menu: TIMenuItemIntf;
begin
  inherited Create;
  MenuItem := nil;
  if ToolServices <> nil then begin { I'm an expert! }
    Main := ToolServices.GetMainMenu;
    if Main <> nil then begin { we've got the main menu! }
      try
        { add the menu of your choice }
        ReferenceMenuItem := Main.FindMenuItem('ToolsOptionsItem');
        if ReferenceMenuItem <> nil then
        try
          Menu := ReferenceMenuItem.GetParent;
          if Menu <> nil then
          try
            MenuItem := Menu.InsertItem(ReferenceMenuItem.GetIndex+1,
                              'IDETree',
                              'IDETreeExpertItem','',
                              0,0,0,
                              [mfEnabled, mfVisible], OnClick);
          finally
            Menu.DestroyMenuItem;
          end;
        finally
          ReferenceMenuItem.DestroyMenuItem;
        end;
      finally
        Main.Free;
      end;
    end;
  end;
end;

destructor TIDETreeExpert.Destroy;
begin
  if MenuItem <> nil then
    MenuItem.DestroyMenuItem;
  inherited Destroy;
end;{Destroy}

procedure TIDETreeExpert.OnClick( Sender: TIMenuItemIntf);
begin
  if not Assigned(frmIDETree) then
    frmIDETree := TfrmIDETree.Create(Application);
  frmIDETree.Show;
  frmIDETree.SetFocus
end;


function AddType(aNode: TTreeNode; Name: String; Info: PTypeInfo): TTreeNode;
begin
  Result:= frmIDETree.TreeView1.Items.AddChild(aNode, Name + ': ' + Info^.Name);
  Result.Data:= TObject(Info);
end;

Function LookupStuff : Boolean;
Var
  i, j, k, l: Integer;
Begin
  frmIDETree.TreeView1.items.clear;
  TopNode:= AddType(nil, Application.Name, Application.ClassInfo);
  frmIDETree.Memo1.Clear;
  Try
  for i:=0 to Application.ComponentCount-1 do
    Begin
      Level1Child:= AddType(TopNode, Application.Components[i].Name,
                    Application.Components[i].ClassInfo);
      for j:=0 to Application.Components[i].ComponentCount-1 do
        begin
          Level2Child:= AddType(Level1Child, Application.Components[i].Components[j].Name,
                        Application.Components[i].Components[j].ClassInfo);
          for k:=0 to Application.Components[i].Components[j].ComponentCount-1 do
            begin
              Level3Child:= AddType(Level2Child, Application.Components[i].Components[j].Components[k].Name,
                            Application.Components[i].Components[j].Components[k].ClassInfo);
              for l:=0 to Application.Components[i].Components[j].Components[k].ComponentCount-1 do
                begin
                  Level4Child:= AddType(Level3Child, Application.Components[i].Components[j].Components[k].Components[l].Name,
                                Application.Components[i].Components[j].Components[k].Components[l].ClassInfo);
                end;
            end;
        end;
      End;
  finally
  End;
End;

{$I S_Delphi.inc}

{ Write the ordinal type. }
procedure WriteOrdType(OrdType: TOrdType);
begin
  frmIDETree.Memo1.Lines.Add('  OrdType: '+ EnumName(Ord(OrdType), TypeInfo(TOrdType)));
end;

{ Return a string representation of a character. If the character
  is printable ASCII, then return the character in quotes; otherwise
  return the character as an ordinal value, e.g., #0. }
function CharToString(C: Cardinal): string;
begin
  { If C is printable, then print it; otherwise,
    print its ordinal value. }
  if (Chr(C) < ' ') or (C > 127) then
    Result := Format('#%d', [C])
  else
    Result := '''' + Chr(C) + ''''
end;

{ Write the type information for a character or wide character. }
procedure WriteCharData(Data: PTypeData);
begin
  with Data^ do
  begin
    WriteOrdType(OrdType);
    frmIDETree.Memo1.Lines.Add('  MinValue: ' + CharToString(MinValue));
    frmIDETree.Memo1.Lines.Add('  MaxValue: '+ CharToString(MaxValue));
  end;
end;

{ Write the information for a single property. }
procedure WritePropInfo(Info: PPropInfo);
begin
  with Info^ do
  begin
    frmIDETree.Memo1.Lines.Add(' property '+ Name+ ': '+ PropType^.Name);
    frmIDETree.Memo1.Lines.Add('   GetProc: '+ Format('%p', [GetProc]));
    frmIDETree.Memo1.Lines.Add('   SetProc: '+ Format('%p', [SetProc]));
    frmIDETree.Memo1.Lines.Add('   StoredProc: '+ Format('%p', [StoredProc]));
    frmIDETree.Memo1.Lines.Add('   Index: '+ IntToStr(Index));
    frmIDETree.Memo1.Lines.Add('   Default: '+ IntToStr(Default));
    frmIDETree.Memo1.Lines.Add('   NameIndex: ' + IntToStr(NameIndex));
  end;
end;

{ Write the information for all the properties of a class. }
procedure WritePropertyInfo(Info: PTypeInfo; Data: PTypeData);
var
  I: Integer;
  PropList: PPropList;
begin
  GetMem(PropList, Data^.PropCount * SizeOf(PPropInfo));
  try
    GetPropInfos(Info, PropList);
    for I := 0 to Data^.PropCount-1 do
      WritePropInfo(PropList^[I]);
  finally
    FreeMem(PropList, Data^.PropCount * SizeOf(PPropInfo));
  end;
end;

{ Write the type information for a class. Write all the
  published properties. }
procedure WriteClassData(Info: PTypeInfo; Data: PTypeData);
begin
  with Data^ do
  begin
    frmIDETree.Memo1.Lines.Add('  ClassType: '+ ClassType.ClassName);
    frmIDETree.Memo1.Lines.Add('  ParentInfo: ');
    if ParentInfo = nil then
      frmIDETree.Memo1.Lines.Add('nil')        { TObject has a nil ParentInfo }
    else
      frmIDETree.Memo1.Lines.Add(ParentInfo^.Name);
    frmIDETree.Memo1.Lines.Add('  PropCount: '+ IntToStr(PropCount));
    WritePropertyInfo(Info, Data);
  end;
end;

{ Write the type information for a floating point type. }
procedure WriteFloatData(Data: PTypeData);
begin
  with Data^ do
    frmIDETree.Memo1.Lines.Add('  FloatType: '+ EnumName(Ord(FloatType), TypeInfo(TFloatType)));
end;

{ Write the type information for an integer type. }
procedure WriteIntegerData(Data: PTypeData);
begin
  with Data^ do
  begin
    WriteOrdType(OrdType);
    frmIDETree.Memo1.Lines.Add('  MinValue: ' +IntToStr(MinValue));
    frmIDETree.Memo1.Lines.Add('  MaxValue: '+ IntToStr(MaxValue));
  end;
end;

{ Parameter information is stored in a packed character array.
  The GetParamInfo procedure unpacks the data into a TParamList
  array. }
type
  TParamFlag = (pfVar, pfConst, pfArray);
  TParamFlags = set of TParamFlag;
  PParamString = PShortString;
  TParamInfo = record
    Flags: TParamFlags;
    ParamName: PParamString;
    ParamType: PParamString;
  end;
  TParamList = array[0..255] of TParamInfo;
  PParamList = ^TParamList;

{ Get the infromation for a parameter list, and store
  it in the ParamList argument. }
procedure GetParamInfo(Data: PTypeData; var Params: TParamList;
                       var ReturnType: PParamString);
var
  I: Integer;
  Ptr: PByte;
begin
  with Data^ do
  begin
    Ptr := PByte(@ParamList);
    for I := 0 to ParamCount-1 do
      with Params[I] do
      begin
        Flags := TParamFlags(Ptr^);
        Inc(Ptr);
        ParamName := PParamString(Ptr);
        Inc(Ptr, Length(ParamName^) + 1);
        ParamType := PParamString(Ptr);
        Inc(Ptr, Length(ParamType^) + 1);
      end;
    if MethodKind = mkFunction then
      ReturnType := PParamString(Ptr);
  end;
end;

{ Write the information for a method, including all the parameters.
  If the method is a function, then show the return type, too. }

procedure WriteMethodData(Data: PTypeData);
var
  I: Integer;
  Params: PParamList;
  Return: PParamString;
begin
  with Data^ do
  begin
    frmIDETree.Memo1.Lines.Add('  MethodKind: '+
       EnumName(Ord(MethodKind), TypeInfo(TMethodKind)));
    frmIDETree.Memo1.Lines.Add('  ParamCount: '+ IntToStr(ParamCount));

    { Allocate memory to hold all the parameter information }
    GetMem(Params, ParamCount * SizeOf(TParamInfo));
    try
      GetParamInfo(Data, Params^, Return);
      { Write each parameter: }
      for I := 0 to ParamCount-1 do
        with Params^[I] do
        begin
          frmIDETree.Memo1.Lines.Add('    Param #'+ intToStr(I) + '=');
          if pfVar in Flags then
            frmIDETree.Memo1.Lines.Add('var ');
          if pfConst in Flags then
            frmIDETree.Memo1.Lines.Add('const ');
          Write(ParamName^, ': ');
          if pfArray in Flags then
            frmIDETree.Memo1.Lines.Add('array of ');
          frmIDETree.Memo1.Lines.Add(ParamType^ + ';');
        end;
    finally
      FreeMem(Params, ParamCount * SizeOf(TParamInfo));
    end;
    if MethodKind = mkFunction then
      frmIDETree.Memo1.Lines.Add('  ReturnType: ' + Return^);
  end;
end;

{ Write the type information for a short string type. }
procedure WriteStringData(Data: PTypeData);
begin
  with Data^ do
    frmIDETree.Memo1.Lines.Add('  MaxLength: ' + IntToStr(MaxLength));
end;

{ Write the type information for an enumerated type.
  Show all the literal names. If this is a subrange,
  then show the type info of the base type. }
procedure WriteEnumData(Info: PTypeInfo; Data: PTypeData);
var
  I: LongInt;
begin
  with Data^ do
  begin
    WriteOrdType(OrdType);
    frmIDETree.Memo1.Lines.Add('  MinValue: '+ IntToStr(MinValue));
    frmIDETree.Memo1.Lines.Add('  MaxValue: '+ IntToStr(MaxValue));
    frmIDETree.Memo1.Lines.Add('  BaseType:');
    { Avoid an infinite loop when the BaseType is the current type. }
    if BaseType{$ifdef Delphi3}^{$endif} <> Info then
      WriteTypeInfo(BaseType{$ifdef Delphi3}^{$endif});
    frmIDETree.Memo1.Lines.Add('  NameList: (');
    { Show all the enumerated literals }
    for I := MinValue to MaxValue do
    begin
      frmIDETree.Memo1.Lines.Add(EnumName(I, Info));
      if I < MaxValue then
        frmIDETree.Memo1.Lines.Add(', ');
    end;
    frmIDETree.Memo1.Lines.Add(')');
  end;
end;

{ Write the type information for a set type.
  Also show the base enumerated type. }
procedure WriteSetData(Data: PTypeData);
begin
  with Data^ do
  begin
    WriteOrdType(OrdType);
    WriteTypeInfo(CompType{$ifdef Delphi3}^{$endif});
  end;
end;


{ Write the full type information. }
procedure WriteTypeInfo(Info: PTypeInfo);
var
  Data: PTypeData;
begin
  frmIDETree.Memo1.Lines.Add('TypeInfo(' + Info^.Name + ')=');
  frmIDETree.Memo1.Lines.Add('  Kind: ' + EnumName(Ord(Info^.Kind), TypeInfo(TTypeKind)));
  Data := GetTypeData(Info);
  case Info^.Kind of
{$ifdef WIN32}
  tkWChar,
{$endif}
  tkChar:      WriteCharData(Data);
  tkClass:     WriteClassData(Info, Data);
  tkEnumeration: WriteEnumData(Info, Data);
  tkFloat:     WriteFloatData(Data);
  tkInteger:   WriteIntegerData(Data);
  tkMethod:    WriteMethodData(Data);
  tkSet:       WriteSetData(Data);
  tkString:    WriteStringData(Data);
  { The following have no additional type data. }
{$ifdef Delphi2}
  tkLString, tkVariant,
{$ifdef Delphi3}
  tkWString,
{$endif}
{$endif}
    tkUnknown: ;
  end;
end;


{ TfrmIDETree code }

procedure TfrmIDETree.TreeView1Change(Sender: TObject; Node: TTreeNode);
begin
  Memo1.Clear;
  Memo1.Lines.BeginUpdate;
  try
    with TreeView1 do
      WriteTypeInfo(PTypeInfo(Node.Data));
  finally
    Memo1.Lines.EndUpdate;
  end;
end;

procedure TfrmIDETree.FormShow(Sender: TObject);
begin
  Memo1.Clear;
  TreeView1.Items.BeginUpdate;
  LookupStuff;
  TreeView1.Items.EndUpdate;
end;

procedure TfrmIDETree.TreeView1Deletion(Sender: TObject; Node: TTreeNode);
begin
  Node.Data:= nil;
end;

end.